ADO ile Şartlı Veri Güncelleme

ADO ile Şartlı Veri Güncelleme, ilgili işlemin VBA kodları ile nasıl yapacağınızı öğreten bir Hazır Makro Kodu içermektedir.

Hazır Kod: ADO ile Şartlı Veri Güncelleme​

Sub ado_ile_sartli_veri_guncelleme()
    Dim vaFiles As Variant, wbkToCopy As Workbook, ws As Worksheet, wsa As Worksheet, depo As Range
    ThisWorkbook.Activate
    Set ws = Sheet2
    un = "Dear " & Environ("UserName")
    ms1 = MsgBox("Do You Want to Import Data from Multiple Workbooks", vbInformation + vbYesNo, un)
    If ms1 = vbYes Then
    ChDir (ThisWorkbook.Path)
    vaFiles = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks(*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xls;*.xlsx;*.xlsb;*.xlsm", Title:="Select Files to Proceed", MultiSelect:=True)
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    say = ws.Cells(175, 3).End(3).Row + 1
    If say < 4 Then say = 4
    If IsArray(vaFiles) Then
        For i = LBound(vaFiles) To UBound(vaFiles)
            If vaFiles(i) = ThisWorkbook.Path & Application.PathSeparator & ThisWorkbook.Name Then
                ms4 = MsgBox("Cannot Open Itself", vbExclamation, un)
                GoTo skipfile:
            End If
            Set wbkToCopy = Workbooks.Open(Filename:=vaFiles(i))
            Set wsa = ActiveWorkbook.ActiveSheet
   
            Set depo = ThisWorkbook.Worksheets(1).Columns(3).Find(wsa.Range("B2").Value, , , 1)
            If Not depo Is Nothing Then
                ws.Cells(depo.Row, "C") = wsa.Range("B2")
                ws.Cells(depo.Row, "D") = wsa.Range("B1")
                ws.Cells(depo.Row, "E") = wsa.Range("B5")
                ws.Cells(depo.Row, "F") = wsa.Range("P4")
                ws.Cells(depo.Row, "H") = wsa.Range("Q4")
                ws.Cells(depo.Row, "J") = wsa.Range("S4")
                ws.Cells(depo.Row, "L") = wsa.Range("T4")
                ws.Cells(depo.Row, "O") = wsa.Range("B3")
                ws.Cells(depo.Row, "R") = wsa.Range("B4")
                wbkToCopy.Close savechanges:=False
            Else
                ws.Cells(say, "C") = wsa.Range("B2")
                ws.Cells(say, "D") = wsa.Range("B1")
                ws.Cells(say, "E") = wsa.Range("B5")
                ws.Cells(say, "F") = wsa.Range("P4")
                ws.Cells(say, "H") = wsa.Range("Q4")
                ws.Cells(say, "J") = wsa.Range("S4")
                ws.Cells(say, "L") = wsa.Range("T4")
                ws.Cells(say, "O") = wsa.Range("B3")
                ws.Cells(say, "R") = wsa.Range("B4")
                wbkToCopy.Close savechanges:=False
                say = say + 1
            End If
skipfile:
        Next i
        ms5 = MsgBox("Data Import Finished", vbInformation, un)
    Else
        ms3 = MsgBox("No Files Selected", vbExclamation, un)
    End If
    Else
        ms2 = MsgBox("Cancelled", vbInformation, un)
    End If
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
End Sub

Açıklama

Kodları, sayfa isimlerini vs kendi çalışmalarınıza uyarlamanız gerekmektedir.

Faydalanılması temennisiyle.